perm filename CLEFXG.F4[NEW,LCS]9 blob sn#423430 filedate 1979-03-07 generic text, type T, neo UTF8
00100	 	SUBROUTINE CLEFS
00200		COMMON /LIB/ KPNT1(10),K1,KPNT2(10),K2,KPNT3(10),K3,KPNT4(10),
00300		1 K4,KPNT5(10),K5,KPNT6(10),K6,KPNT7(10),K7,KPNT8(10),K8,
00400		1 JCLF1(350),JCLF2(350),JCLF3(350),JCLF4(350),
00500		1 JCLF5(350),JCLF6(350),JCLF7(350),JCLF8(350),
00600		1 NMX(1),NM2,NM3,NM4,NM5,NM6,NM7,NM8
00700		DIMENSION RCMIN(4),CM(4)
00800		COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS,XDIS/BM/F,G,H
00900		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /MIN/MINI,RMINI
01000	      DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/
01100		EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J9,JQ(7)),
01200		1 (R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5))
01300		1,(DEG,R9,RJQ(7)),(NJR,RJQ(8)),(R3,RJQ(1)),(J8,JQ(6))
01400	CX	J5=MOD(J5,100)
01500	CX	IF(J5)J5=-J5
01600		IF(R6.GE.100)R6=R6-100
01700	C SOMETIMES MAKE SIZE +100 FOR PARTS PROGRAM.
01800		CALL NOZERO(R6)
01900		IF(R7.EQ.0)R7=R6
02000	C  IF P7 = 0, IT WILL EQUAL P6.
02100		IF(JA.GT.10)GO TO 9
02200		NAME='CLEFA'
02300		IF(J5.LT.20)GO TO 4
02400		R6=R6*.3
02500	C  SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
02600		R7=R7*.3
02700		GO TO 4
02800	9	IF(NAME.EQ.NJR)GO TO 4
02900		IF(NAME.EQ.0)GO TO 177
03000		IF(NJR.EQ.0)GO TO 4
03100	177	IF(NJR.EQ.0)GO TO 8	
03200	C  TO PICK UP BASIC DRAW NAME FROM P10 
03300		NAME=NJR
03400		GO TO 4
03500	8	TYPE 5
03600	5	FORMAT(' SET P10=1'/)
03700	C  LEADS TO PROPER FILE CALL
03800	4	JTAIL=-1
03900		IF(JA.NE.3)GO TO 44
04000		IF(R5.NE.0.8)GO TO 44
04100		JTAIL=0
04200	C R5=0.8 FOR TREBLE CLEF WITH 8 ON TAIL. (FOR TENOR VOCAL)
04300	44	NM=NAME+2*(J5/10)
04400	C  DRAW0 HAS ITEMS 0→9;  DRAW1, 10→19; ETC. TO DRAW9, 90→99
04500		JEZ=MOD(J5,10)+1
04600	2	DO 200 K=1,8
04700	200	IF(NMX(K).EQ.NM)GO TO 30
04800	C  SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
04900	C  JUMP IF ALREADY IN CORE
05000		NPP=0
05100		IF(JA.NE.11)GO TO 1111
05200	C  DOESN'T CHECK LOOKUP ON CLEFS AND ALPHA'S.
05300		NPP=-1
05400		IF(LOOKF(NM))GO TO 1111
05500		TYPE 1112,NM
05600		RETURN    
05700	1112	FORMAT(1XA5,' -- NOT FOUND')
05800		KX=0
05900	1111	CALL GETFI2(NM,NPP)
06000		GO TO(33,233,333,433,533,633,733),KX
06100	C  GOES TO 133 WHEN KX IS 0
06200	133	CALL FASTI2(KPNT1,11)
06300		CALL FASTI2(JCLF1,K1)
06400	C  NEW DATA READER  6/74 -- 5/75  HOLDS 3 .DMD FILES IF THEY FIT.
06500		IF(K1.LE.350)GO TO 300
06600	C???	KX=0
06700	C???	NM2=0
06800	C???	GO TO 30
06900		GO TO 300
07000	33	CALL FASTI2(KPNT2,11)
07100		IF(K2.GT.350)GO TO 1112
07200	C  JUMP BACK IF IT WON'T FIT.
07300		CALL FASTI2(JCLF2,K2)
07400		GO TO 300
07500	233	CALL FASTI2(KPNT3,11)
07600		IF(K3.GT.350)GO TO 1112
07700	C  JUMP BACK IF IT WON'T FIT.
07800		CALL FASTI2(JCLF3,K3)
07900	C  R6 IS SIZE FACTOR
08000		GO TO 300
08100	333	CALL FASTI2(KPNT4,11)
08200		IF(K4.GT.350)GO TO 1112
08300	C  JUMP BACK IF IT WON'T FIT.
08400		CALL FASTI2(JCLF4,K4)
08500		GO TO 300
08600	433	CALL FASTI2(KPNT5,11)
08700		IF(K5.GT.350)GO TO 1112
08800	C  JUMP BACK IF IT WON'T FIT.
08900		CALL FASTI2(JCLF5,K5)
09000		GO TO 300
09100	533	CALL FASTI2(KPNT6,11)
09200		IF(K6.GT.350)GO TO 1112
09300	C  JUMP BACK IF IT WON'T FIT.
09400		CALL FASTI2(JCLF6,K6)
09500		GO TO 300
09600	633	CALL FASTI2(KPNT7,11)
09700		IF(K7.GT.350)GO TO 1112
09800	C  JUMP BACK IF IT WON'T FIT.
09900		CALL FASTI2(JCLF7,K7)
10000	300	KX=KX+1
10100		NMX(KX)=NM
10200		GO TO 30
10300	733	CALL FASTI2(KPNT8,11)
10400		IF(K8.GT.350)GO TO 1112
10500	C  JUMP BACK IF IT WON'T FIT.
10600		CALL FASTI2(JCLF8,K8)
10700		KX=0
10800	C RESET POINTER TO FIRST SLOT (NMX(1) )
10900		NMX(8)=NM
11000	30	IF(J5.GT.3)GO TO 811
11100		IF(JA.NE.3)GO TO 811
11200	C  0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)  MINI→R4+100
11300	C  ↑↑↑↑↑↑↑↑  FIXUP SOMEDAY IN .DMD FILES
11400		IF(IABS(J4).LT.80)GO TO 812
11500		RSTJ2=.8*RSTJ2
11600	C  TO SET HGT. OF MINI CLEFS
11700		R4=R4+CM(JEZ)
11800	C  SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
11900	812	IF(JEZ.NE.4)GO TO 811
12000		R4=R4+2
12100		JEZ=3
12200	C   ABOVE IS NOW AT TOP
12300	
12400	811	A=R4
12500		R4=A+2.9
12600	C  ADJUSTS HEIGHT(??)
12700		CALL CENTX
12800		R4=A
12900	
13000		DO 201 K=1,8
13100	201	IF(NM.EQ.NMX(K))L=KPNT1(JEZ+(K-1)*11)+350*(K-1)
13200	C ABOVE SETS POINTER TO LIBRARY STORAGE ARRAY.
13300		IF(L.LE.0)RETURN
13400	C CATCHES IMPOSSIBLE NUMBERS (I HOPE!)
13500		IF(J9.EQ.0)GO TO 31
13600	C***** ROTATE *******
13700		R7=R7*RSTJ2
13800		R6=R6*RSTJ2
13900		N=JCLF1(L)
14000		KNT=701
14100	C ROTATED DATA IS PUT STARTING AT LOCATION 701.(AREA FOR NM3)******
14200		JCLF1(KNT)=N
14300		DO 1 K=L+1,N+L-1
14400		CALL UNPACK(J,M,JCLF1(K))
14500		X=J*R6
14600		Y=M*R7
14700		JJ=JCLF1(K)/100000000
14800		AX=ATAN2(X,Y)*57.29578
14900		HYP=SQRT(X**2+Y**2)
15000		ROT=DEG+AX
15100		J=ROFF(HYP*COSD(ROT))
15200		M=ROFF(HYP*SIND(ROT))
15300		KNT=KNT+1
15400		IF(J)J=1000-J
15500		IF(M)M=1000-M
15600	1	JCLF1(KNT)=M*10000+J+JJ*100000000
15700		L=701
15800	C  ***********  SEE AT TOP **********
15900		R6=1.
16000		R7=1.
16100		RSTJ2=1.
16200	C  SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
16300		NM3=0
16400	C  WIPES OUT DATA AREA FOR NM3
16500	C  R9=P9=DEGREES OF ROTATION (0-360)
16600		IF(KK.GT.350)KX=0
16700	C CHECK TO SEE IF DATA WAS WIPED OUT.
16800	31	A=-1
16900	C  FLAG FOR THICKNESS OR NO.
17000		IF(J8.EQ.-2)GO TO 32
17100		IF(R8.LE.0)GO TO 34
17200		A=0
17300	C NEXT J8 = 1→99 =X THICKNESS, =100→ = Y THICKNESS
17400		CALL THICK
17500	C  SEE CLEFZ.F4 FOR "THICK" CODE  (THICK IS IN MFAIL.FAI)
17600		GO TO 32
17700	CC34	IF(IPLT)GO TO 77
17800	CC31	IF(R8.EQ.-2)GO TO 32
17900	C			R8=-2 OMITS FILLER DURING PLOT
18000	CCC	IF(IPLT)GO TO 77
18100	34	IF(IPLT)77,77,32
18200	CCCC	IF(R8.NE.-1)GO TO 32
18300	77	DO 3 K=L+1,JCLF1(L)+L-1
18400		IF(JCLF1(K).LT.200000000)GO TO 3
18500		JEZ=JCLF1(L)-1
18600		IF(K.GT.L+1)JEZ=JEZ-K+L+1
18700		CALL FILLMS(JEZ,JCLF1(K),R3,CENTR,R6,R7)
18800		GO TO 32
18900	3	CONTINUE
19000	C  FILLS ONLY WHEN PLOTING OR R8=-1
19100	32	CALL JDRAW(JCLF1(L),R3,CENTR,RSTJ2,R6,R7)
19200	C   3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
19300		IF(A)GO TO 334
19400		IF(J8.NE.0)GO TO 234
19500		IF(J9.EQ.0)GO TO 334
19600		GO TO 134
19700	234	J8=J8-1
19800		R3=R3+XDIS
19900	C  XDIS=1 PLOTTER STEP NO MATTER WHAT SIZE FACTOR USED
20000	134	IF(J9.EQ.0)GO TO 32
20100		J9=J9-1
20200		CENTR=CENTR+XDIS
20300		GO TO 32
20400	334	IF(JTAIL)RETURN
20500		JTAIL=-1
20600		JA=10
20700		JEZ=9
20800	C  JEZ=9 MAKES AN 8 APPEAR UNDER TAIL OF TREBLE CLEF.
20900		R6=.2
21000		R7=R6
21100		NM='BDR40'
21200		R3=R3+14*RSTJ2
21300		R4=-4
21400		GO TO 2
21500		END